home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 050 / madtrb31.arc / GRAFDEMO.PAS < prev    next >
Pascal/Delphi Source File  |  1985-05-15  |  4KB  |  156 lines
  1. Program GrafDemo;       { Author: William P. Smith  }
  2.                         {         Mitchellville, Md }
  3.  
  4. Type
  5.       line = String[80];
  6.       GraphFileName = String[15];
  7.  
  8. Var
  9.       color,n,i:integer;
  10.       name: Array[1..10] of GraphFileName;
  11.       scrnfil: File;
  12.       Buffer1,Buffer2,Buffer3: Array[1..$4000] of Byte;
  13.       Video: Byte Absolute $B800:0000;
  14.       ah,al: Byte;
  15.       ch: char;
  16.  
  17. function mkstr(ch: char; n: integer): line;
  18. var st: line;
  19.     i: integer;
  20. begin
  21.   st:='';
  22.   for i:=1 to n do st:=st+ch;
  23.   mkstr:=st;
  24. end;
  25. procedure Vwrite(st: line; attribute: byte);
  26. var X,Y,i: integer;
  27. begin
  28.   X:=whereX; Y:=whereY;
  29.   write(st);
  30.   for i:=1 to length(st) do mem[$B800:2*((Y-1)*80+i+X-2)+1]:=attribute;
  31. end;
  32. procedure Box(st: line);
  33. var X,Y: byte;
  34.     ch: char;
  35. begin
  36.   ch:=chr(205);
  37.   x:=whereX; Y:=whereY;
  38.   gotoxy(X,Y); write(#201,mkstr(ch,length(st)+2),#187);
  39.   gotoxy(X,Y+1); write(#186); gotoxy(X+length(st)+3,Y+1); write(#186);
  40.   gotoxy(X,Y+2); write(#200,mkstr(ch,length(st)+2),#188);
  41.   gotoxy(X+2,Y+1); Vwrite(st,$70);
  42. end;
  43. procedure GetScanCode(var ah,al: byte);
  44. type
  45.   regpack = record
  46.               ax,bx,cx,dx,bp,di,si,ds,es,flags: integer;
  47.             end;
  48. var
  49.   recpack: regpack;
  50.  
  51. begin
  52.   ah := $0;
  53.   with recpack do
  54.   begin
  55.     ax := ah shl 8 + al;
  56.   end;
  57.   intr($16,recpack);
  58.   with recpack do
  59.   begin
  60.     ah:=ax shr 8;
  61.     al:=ax mod 256;
  62.   end;
  63. end;
  64. procedure GetColor;
  65. var  row,col: integer;
  66. procedure hilite(attribute: byte);
  67. var X,Y,i: integer;
  68. begin
  69.   X:=whereX; Y:=whereY;
  70.   for i:=1 to 11 do mem[$B800:2*((Y-1)*80+i+X-2)+1]:=attribute;
  71. end;
  72. procedure ListColors;
  73. begin
  74.   col:=30; row:=15;
  75.   gotoxy(col,row); write(#201,mkstr(chr(205),11),#187);
  76.   gotoxy(col,row+1); write(#186,'  Blue     ',#186);
  77.   gotoxy(col,row+2); write(#186,'  Green    ',#186);
  78.   gotoxy(col,row+3); write(#186,'  Cyan     ',#186);
  79.   gotoxy(col,row+4); write(#186,'  Red      ',#186);
  80.   gotoxy(col,row+5); write(#186,'  Magenta  ',#186);
  81.   gotoxy(col,row+6); write(#186,'  Brown    ',#186);
  82.   gotoxy(col,row+7); write(#186,'  Yellow   ',#186);
  83.   gotoxy(col,row+8); write(#186,'  White    ',#186);
  84.   gotoxy(col,row+9); write(#200,mkstr(chr(205),11),#188);
  85. end;
  86. procedure select(var varnum: integer);
  87. begin
  88.   repeat
  89.     getScanCode(ah,al);
  90.     case ah of
  91.       72: begin
  92.             varnum:=varnum-1;
  93.             if varnum<1 then varnum:=8;
  94.           end;
  95.       80: begin
  96.             varnum:=varnum+1;
  97.             if varnum>8 then varnum:=1;
  98.           end;
  99.     end;
  100.     hilite($7);
  101.     gotoxy(col+1,row+varnum);
  102.     hilite($70);
  103.   until al=13;
  104. end;
  105. begin
  106.   listcolors;
  107.   color:=1;
  108.   gotoxy(col+1,row+color);
  109.   hilite($70);
  110.   select(color);
  111.   if color>6 then color:=color+7;
  112. end;
  113. begin
  114.   gotoxy(19,1); Box(' TURBO  PASCAL  GRAPHICS  DEMO ');
  115.   gotoxy(35,4); write('by');
  116.   gotoxy(28,5); write('William P. Smith');
  117.   lowvideo;
  118.   gotoxy(28,6); write('Mitchellville, MD');
  119.   gotoxy(1,10); write('This is a demonstration of some ');
  120.   Vwrite('3-D',$8F);
  121.   writeln(' graphics that I created with Turbo.  To');
  122.   writeln('begin select a color.  Each graph will continue to be displayed until any');
  123.   Vwrite('key',$70);
  124.   writeln(' is pressed.  A high resolution graphics display device is required.');
  125.   write('Please use cursor keys to choose desired color then confirm with CR.  ');
  126.   Vwrite('Enjoy!',$F0);
  127.   name[1]:='peak';
  128.   name[2]:='towers';
  129.   name[3]:='peaks';
  130.   name[4]:='sinexp';
  131.   name[5]:='cosexp';
  132.   name[6]:='well';
  133.   name[7]:='sph1';
  134.   GetColor;
  135.   for n:=1 to 7 do begin
  136.     assign(scrnfil,name[n]+'.pic'); reset(scrnfil);
  137.     blockread(scrnfil,buffer1,128);
  138.     close(scrnfil);
  139.     hires; hirescolor(color);
  140.     move(Buffer1,Video,$4000);
  141.     read(kbd,ch);
  142.   end;
  143.   assign(scrnfil,'sph2.pic');  reset(scrnfil);
  144.   blockread(scrnfil,Buffer2,128);
  145.   close(scrnfil);
  146.   assign(scrnfil,'sph3.pic');  reset(scrnfil);
  147.   blockread(scrnfil,Buffer3,128);
  148.   close(scrnfil);
  149.   repeat
  150.     move(Buffer2,Video,$4000);
  151.     move(Buffer3,Video,$4000);
  152.     move(Buffer1,Video,$4000);
  153.   until keypressed;
  154.   textmode(2);
  155.   gotoxy(30,13); Vwrite('  That''s all folks!  ',$F0);
  156. end.